home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / proj21sw / filetest.bas < prev    next >
BASIC Source File  |  1995-07-18  |  10KB  |  394 lines
  1. ' Tuomas Salste
  2. ' File name parsing library
  3. ' Included as an example for Project Analyzer
  4. ' These functions will not necessarily work
  5.  
  6. Option Explicit
  7. DefInt A-Z
  8.  
  9. Type FilenameType
  10.    drive As String '* 8
  11.    Path As String '* 63
  12.    Filename As String '* 12
  13.    Basename As String '* 8
  14.    Extension As String '* 3
  15. End Type
  16.  
  17. Global FName As FilenameType
  18.  
  19. Global Const DRIVE_FLOPPY = 2
  20. Global Const DRIVE_FIXED = 1
  21. Global Const DRIVE_NETWORK = 0
  22.  
  23. ' DiskSpaceFree function uses this in SETUPKIT.DLL
  24. ' Not needed if not used
  25. Declare Function DiskSpaceFree_DLL Lib "SETUPKIT.DLL" Alias "DiskSpaceFree" () As Long
  26.  
  27. Function AbsPath (ByVal BaseDir As String, ByVal Path As String) As String
  28. ' Gives Absolute Path from Relative Path
  29.  
  30. Dim GivenPath As FilenameType
  31. Dim Result As Integer
  32. Result = FileNameSplit(Path, GivenPath)
  33. If GivenPath.drive <> "" Then
  34.     On Error Resume Next
  35.     BaseDir = CurDir(GivenPath.drive)
  36.     If Err Then
  37.     BaseDir = GivenPath.drive + "\"
  38.     End If
  39.     On Error GoTo 0
  40. Else
  41.     If BaseDir = "" Then
  42.     BaseDir = CurDir
  43.     End If
  44. End If
  45.  
  46. Dim nDir As String
  47. Do While Path <> ""
  48.     nDir = NextDir(Path)
  49.     Select Case nDir
  50.     Case ".."
  51.         Dim BackPath As FilenameType
  52.         Result = FileNameSplit(BaseDir, BackPath)
  53.         BaseDir = BackPath.Path
  54.     Case "."
  55.     Case "\"
  56.         BaseDir = DriveOnly(BaseDir) + "\"
  57.     Case Else
  58.         BaseDir = PathNameWithSlash(BaseDir) & nDir
  59.     End Select
  60. Loop
  61. AbsPath = UCase(BaseDir)
  62.  
  63. End Function
  64.  
  65. Function Basenameonly (ByVal FileSpec As String) As String
  66. ' Returns the base name of a filespec
  67. ' FileSpec can be a directory name too
  68.  
  69. Dim Filename As FilenameType
  70. Dim Result As Integer
  71. Result = FileNameSplit(FileSpec, Filename)
  72. Basenameonly = Filename.Basename
  73.  
  74. End Function
  75.  
  76. Function ChangeFilenameExtension (ByVal OldFilename As String, ByVal NewExtension As String) As String
  77. ' Example:
  78. ' ChangeFilenameExtension("AUTOEXEC.BAT", "TMP")
  79. ' results in "AUTOEXEC.TMP"
  80. ' Returns "" in error
  81.  
  82. Dim File As FilenameType
  83. If FileNameSplit(OldFilename, File) Then
  84.     File.Extension = NewExtension
  85.     File.Filename = File.Basename & "." & File.Extension
  86.     ChangeFilenameExtension = FileNameExpand(File)
  87. Else
  88.     Exit Function
  89. End If
  90.  
  91. End Function
  92.  
  93. '------------------------------------------------
  94. ' Get the disk space free for the current drive
  95. '------------------------------------------------
  96. Function DiskSpaceFree (drive As String) As Long
  97.  
  98. Dim OldDrive As String
  99. OldDrive = DriveOnly(CurDir)
  100.  
  101. On Error Resume Next
  102. ChDrive drive
  103. If Err = 0 Then
  104.     DiskSpaceFree = DiskSpaceFree_DLL()
  105. End If
  106. ChDrive OldDrive
  107.  
  108. End Function
  109.  
  110. Function DriveOnly (ByVal FileSpec As String) As String
  111. ' Returns the drive "D:"
  112.  
  113. Dim File As FilenameType
  114. If FileNameSplit(FileSpec, File) Then
  115.     DriveOnly = File.drive
  116. End If
  117.  
  118. End Function
  119.  
  120. Function DriveType (ByVal DriveLetter As String, DriveListBox As DriveListBox) As Integer
  121. ' Returns the type of a drive
  122. ' Type is one of the following:
  123. ' DRIVE_FLOPPY, DRIVE_FIXED, DRIVE_NETWORK
  124.  
  125. Dim i As Integer
  126. For i = 0 To DriveListBox.ListCount - 1
  127.     If StrComp(Left(DriveListBox.List(i), 1), Left(DriveLetter, 1), 1) = 0 Then
  128.     If Len(DriveListBox.List(i)) = 2 Then
  129.         DriveType = DRIVE_FLOPPY
  130.     ElseIf Mid(DriveListBox.List(i), 3, 2) = "\\" Then
  131.         DriveType = DRIVE_NETWORK
  132.     Else
  133.         
  134.         DriveType = DRIVE_FIXED
  135.     End If
  136.     Exit For
  137.     End If
  138. Next
  139.  
  140. End Function
  141.  
  142. Function ExtensionOnly (ByVal File As String) As String
  143. ' Returns file name extension "BAS"
  144.  
  145. Dim Filename As FilenameType
  146. Dim Result As Integer
  147. Result = FileNameSplit(File, Filename)
  148. ExtensionOnly = Filename.Extension
  149.  
  150. End Function
  151.  
  152. Private Function FileNameExpand (Filename As FilenameType) As String
  153. ' Assembles a qualified file name from separate fields
  154.  
  155. Dim Delimiter$
  156. If Len(RTrim$(Filename.drive)) > 2 Then
  157.     If Filename.drive = String$(8, 0) Then
  158.     FileNameExpand$ = ""
  159.     Else
  160.     FileNameExpand$ = RTrim$(Filename.drive)
  161.     End If
  162. Else
  163.     If Right$(RTrim$(Filename.Path), 1) = ":" Or RTrim$(Filename.Path) = "" Or Right$(RTrim$(Filename.Path), 1) = "\" Then
  164.     Else
  165.     Delimiter$ = "\"
  166.     End If
  167.     If Left$(Filename.Path, 2) = RTrim$(Filename.drive) Then
  168.     FileNameExpand$ = UCase$(RTrim$(Filename.Path) + Delimiter$ + RTrim$(Filename.Filename))
  169.     Else
  170.     FileNameExpand$ = UCase$(RTrim$(Filename.drive) + RTrim$(Filename.Path) + Delimiter$ + RTrim$(Filename.Filename))
  171.     End If
  172. End If
  173.  
  174. End Function
  175.  
  176. Function FilenameOnly (ByVal FileSpec As String) As String
  177. ' Returns the file name part of a FileSpec "FILENAME.BAS"
  178.  
  179. Dim File As FilenameType
  180. If FileNameSplit(FileSpec, File) Then
  181.     FilenameOnly = File.Filename
  182. End If
  183.  
  184. End Function
  185.  
  186. Function FileNameSplit (ByVal FilenameString$, Filename As FilenameType) As Integer
  187. ' Splits a file name into separate fields
  188.  
  189. Dim er As Integer
  190. Dim FilNam$
  191. Dim Colon As Integer
  192. Dim NoDrive As Integer
  193. Dim c As Integer
  194.  
  195. FilNam$ = UCase$(FilenameString$)
  196. Filename.drive = ""
  197. Filename.Path = ""
  198. Filename.Filename = ""
  199. Filename.Basename = ""
  200. Filename.Extension = ""
  201. Colon = InStr(FilNam$, ":")
  202. If Colon = 2 Then
  203.     Filename.drive = Left$(FilNam$, 2)
  204. ElseIf Colon Then
  205.     If Len(FilNam$) > Colon Or Colon < 4 Or Colon > 5 Then
  206.     er = True
  207.     Else
  208.     NoDrive = True
  209.     Filename.drive = Left$(FilNam$, Colon)
  210.     End If
  211. End If
  212. If er = 0 And NoDrive = False Then
  213.     For c = Len(FilNam$) To 1 + Len(RTrim$(Filename.drive)) Step -1
  214.     If Mid$(FilNam$, c, 1) = "\" Then
  215.         If c = Len(RTrim$(Filename.drive)) + 1 Then
  216.         Filename.Path = Left$(FilNam$, c)
  217.         Else
  218.         Filename.Path = Left$(FilNam$, c - 1)
  219.         End If
  220.         Exit For
  221.     End If
  222.     Next
  223.     If RTrim$(Mid$(FilNam$, c + 1)) <> ".." Then
  224.     If InStr(Mid$(FilNam$, c + 1), ".") Then
  225.         Filename.Basename = Left$(Left$(Mid$(FilNam$, c + 1), InStr(Mid$(FilNam$, c + 1), ".") - 1), 8)
  226.         Filename.Extension = Mid$(Mid$(FilNam$, c + 1), InStr(Mid$(FilNam$, c + 1), ".") + 1, 3)
  227.     Else
  228.         Filename.Basename = Mid$(FilNam$, c + 1)
  229.     End If
  230.     Else
  231.     Filename.Path = RTrim$(Filename.Path) + ".."
  232.     End If
  233.     If RTrim$(Filename.Basename) = "" And RTrim$(Filename.Extension) <> "" Then
  234.     er = True
  235.     Filename.Extension = ""
  236.     Filename.Path = ""
  237.     Filename.drive = ""
  238.     Else
  239.     If Len(RTrim$(Filename.Extension)) Then
  240.         Filename.Filename = RTrim$(Filename.Basename) + "." + Filename.Extension
  241.     Else
  242.         Filename.Filename = RTrim$(Filename.Basename)
  243.     End If
  244.     If RTrim$(Filename.Filename) = "." Then Filename.Filename = ""
  245.     End If
  246. End If
  247. If er Then
  248.     FileNameSplit% = False
  249. Else
  250.     FileNameSplit% = True
  251. End If
  252.  
  253. End Function
  254.  
  255. Function IsDir (ByVal FileSpec As String) As Integer
  256.  
  257. Dim Result As Integer
  258. On Local Error Resume Next
  259. Result = GetAttr(FileSpec)
  260. If Err = 0 And Result = 16 Then ' ATTR_DIRECTORY= 16
  261.     IsDir = True
  262. End If
  263.  
  264. End Function
  265.  
  266. Function IsFile (ByVal FileSpec As String) As Integer
  267. ' Returns True if a file called Filename exists
  268. ' Filename CAN NOT contain wildcards
  269.  
  270. Dim Result As String
  271. On Local Error Resume Next
  272. Result = Dir(FileSpec)
  273. If Err = 0 And LCase(Result) = LCase(FilenameOnly(FileSpec)) And Result <> "" Then
  274.     IsFile = True
  275. End If
  276.  
  277. End Function
  278.  
  279. Function IsFileSpec (ByVal Filename As String) As Integer
  280. ' Returns True if Filename is
  281. ' a file, a directory or a volume label
  282. ' Filename must not contain any wildcards
  283.  
  284. Dim Result As Integer
  285. On Local Error Resume Next
  286. Result = GetAttr(Filename)
  287. If Err = 0 Then IsFileSpec = True
  288.  
  289. End Function
  290.  
  291. Function MatchesTemplate% (TestText$, Template$)
  292. ' Checks if a file name matches Template ("FILENAME.BAS", "*.BAS")
  293.  
  294. Dim CheckLen As Integer, c As Integer
  295. Dim TChar$, NoMatch As Integer
  296.  
  297. If Len(Template$) > Len(TestText$) Then
  298.     CheckLen = Len(Template$)
  299. Else
  300.     CheckLen = Len(TestText$)
  301. End If
  302. For c = 1 To CheckLen
  303.     TChar$ = Mid$(Template$, c, 1)
  304.     Select Case TChar$
  305.     Case "?"
  306.     Case "*"
  307.         Exit For
  308.     Case Mid$(TestText$, c, 1)
  309.     Case ""
  310.         NoMatch = True
  311.         Exit For
  312.     Case Else
  313.         NoMatch = True
  314.         Exit For
  315.     End Select
  316. Next
  317. If Len(Template$)